''''''''''''<:-) :SUGGESTION: Inserted by Code Fixer. (Must be placed after Enum Declaration for Code Fixer to recognize it properly)
#If False Then
Private TTIconNone, TTIconInfo, TTIconWarning, TTIconError 'to preserve the case
#End If
'my properties
Private myStyle As TTStyle
Private myIcon As TTIcon
Private myForeColor As Long
Private myBackColor As Long
Private myTitle As String 'has the current title
Private myHoverTime As Long 'time im millisecs (-1 = use default)
Private myPopupTime As Long 'time im millisecs (-1 = use default)
Private myInitialText As Variant 'has the initial text
Private myInitialTitle As Variant 'has the initial title
Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOACTIVATE As Long = &H10
Private Const SWP_FLAGS As Long = SWP_NOACTIVATE Or SWP_NOSIZE Or SWP_NOMOVE
Private Const TOPMOST As Long = -1
Private Const WM_USER As Long = &H400
Private Const TTM_SETDELAYTIME As Long = WM_USER + 3
Private Const TTM_ADDTOOL As Long = WM_USER + 4
Private Const TTM_SETTIPBKCOLOR As Long = WM_USER + 19
Private Const TTM_SETTIPTEXTCOLOR As Long = WM_USER + 20
Private Const TTM_SETTITLE As Long = WM_USER + 32
Private Type RECTANGLE
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type ToolInfo
ttSize As Long
myFlags As Long
ttParhWnd As Long
ttId As Long
ParentRect As RECTANGLE
hInstance As Long
myText As String
lParam As Long
End Type
Private ToolInfo As ToolInfo
'tool property flag bits meaning
Private Const TTF_CENTERTIP As Long = 2 'center tool on parent
Private Const TTF_SUBCLASS As Long = &H10 'use implicit subclassinf
Private Declare Sub InitCommonControls Lib "comctl32" ()
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, _
ByVal lpClassName As String, _
ByVal lpWindowName As String, _
ByVal dwStyle As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hWndParent As Long, _
ByVal hMenu As Long, _
ByVal hInstance As Long, _
lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal wFlags As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, _
lpRect As RECTANGLE) As Long
Public Property Get BackCol() As Long
'this returns the current tooltip backcolor
BackCol = myBackColor
End Property
Public Property Get Centered() As Boolean
'this returns the current tooltip alignment
Centered = CBool(ToolInfo.myFlags And TTF_CENTERTIP)
End Property
Private Sub Class_Initialize()
InitCommonControls 'doesn't matter that this is called for every class instance
myStyle = TTNone
End Sub
Private Sub Class_Terminate()
'kill tooltip window if one exists
If tthWnd Then
DestroyWindow tthWnd
tthWnd = 0
End If
myStyle = TTNone
End Sub
Public Function Create(cntParent As Control, _
ByVal strText As String, _
Optional ByVal ttsStyle As TTStyle = TTBalloonAlways, _
Optional ByVal Centered As Boolean = False, _
Optional ByVal ttiIcon As TTIcon = TTIconNone, _
Optional ByVal Title As String = vbNullString, _
Optional ByVal lngForeColor As Long = vbButtonText, _
Optional ByVal lngBackColor As Long = vbInfoBackground, _
Optional ByVal HoverTime As Long = -1, _
Optional ByVal PopupTime As Long = 99000) As Long
PopupTime = 8000
lngForeColor = 0
lngBackColor = -2147483624
'Create the tooltip window for parent control
'This cannot create custom tooltips for hWnd-less controls
Class_Terminate 'kill tooltip window if one exists
With ToolInfo
On Error Resume Next
.ttParhWnd = cntParent.hwnd
If Err.Number = 0 And (ttsStyle = TTBalloonAlways Or ttsStyle = TTStandardAlways Or ttsStyle = TTBalloonIfActive Or ttsStyle = TTStandardIfActive) And (ttiIcon = TTIconError Or ttiIcon = TTIconInfo Or ttiIcon = TTIconNone Or ttiIcon = TTIconWarning) Then
'the tooltip parent control has an hWnd and the params are acceptable
.ttSize = Len(ToolInfo)
.myFlags = TTF_SUBCLASS Or IIf(Centered, TTF_CENTERTIP, 0&)
GetClientRect .ttParhWnd, .ParentRect
.hInstance = App.hInstance
myTitle = Title
If myInitialTitle = Empty Then
myInitialTitle = myTitle
End If
.myText = Replace$(strText, "|", vbNewLine) 'the vertical bar is used as line break character
If Len(myTitle) = 0 Then
.myText = Replace$(.myText, vbNewLine, " ")
End If
If myInitialText = Empty Then
myInitialText = .myText
End If
If lngForeColor < 0 Then
lngForeColor = GetSysColor(lngForeColor And &H7FFFFFFF) 'GetSysColor(ForeColor And &H7FFFFFFF)
End If
If lngBackColor < 0 Then
lngBackColor = GetSysColor(lngBackColor And &H7FFFFFFF)
